Linux Cubed Series 2: Applications/Linux Cubed Series 2 - Applications.iso/editors/emacs/xemacs/xemacs-1.006/xemacs-1/lib/xemacs-19.13/lisp/prim/frame.el

Text File | 1995-08-18 | 20.4 KB | 555 lines

;;; frame.el --- multi-frame management independent of window systems.

;;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.

;; Maintainer: FSF
;; Keywords: internal

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Code:

(defvar select-frame-hook nil
  "Function or functions to run just after a new frame is given the focus.
Note that calling `select-frame' does not necessarily set the focus:
The actual window-system focus will not be changed until the next time
that XEmacs is waiting for an event, and even then, the window manager
may refuse the focus-change request.")

(defvar deselect-frame-hook nil
  "Function or functions to run just before a frame loses the focus.
See `select-frame-hook'.")

(defvar initial-frame-alist nil
  "Alist of default values for the first frame.
This may be set by the window-system-specific init file.")



;;;; Creating the initial window-system frame

(defun frame-initialize ()
  ;; In batch mode, we actually use the initial terminal device for output.
  (if (not (noninteractive))
      (progn
    ;; Don't call select-frame here - focus is a matter of WM policy.
    (make-frame initial-frame-alist
            (car (delq terminal-device (device-list))))
    (delete-device terminal-device)
    (setq terminal-frame nil))))


;;;; Creation of additional frames, and other frame miscellanea

(defun get-other-frame ()
 "Return some frame other than the current frame, creating one if necessary."
  (let* ((this (selected-frame))
     ;; search visible frames first
     (next (next-frame this 'visible)))
    ;; then search iconified frames
    (if (eq this next)
    (setq next (next-frame this nil)))
    (if (eq this next)
    ;; otherwise, make a new frame
    (make-frame)
      next)))

(defun next-multiframe-window ()
  "Select the next window, regardless of which frame it is on."
  (interactive)
  (select-window (next-window (selected-window)
                  (> (minibuffer-depth) 0)
                  t)))

(defun previous-multiframe-window ()
  "Select the previous window, regardless of which frame it is on."
  (interactive)
  (select-window (previous-window (selected-window)
                  (> (minibuffer-depth) 0)
                  t)))

(defun frame-list ()
  "Return a list of all frames on all devices."
  (apply 'append (mapcar 'device-frame-list (device-list))))

;; Alias, kept temporarily.
(defalias 'new-frame 'make-frame)

(defun filtered-frame-list (predicate)
  "Return a list of all live frames which satisfy PREDICATE."
  (let ((frames (frame-list))
    good-frames)
    (while (consp frames)
      (if (funcall predicate (car frames))
      (setq good-frames (cons (car frames) good-frames)))
      (setq frames (cdr frames)))
    good-frames))

;(defun minibuffer-frame-list ()
;  "Return a list of all frames with their own minibuffers."
;  (filtered-frame-list
;   (function (lambda (frame)
;           (eq frame (window-frame (minibuffer-window frame)))))))

;(defun frame-remove-geometry-params (param-list)
;  "Return the parameter list PARAM-LIST, but with geometry specs removed.
;This deletes all bindings in PARAM-LIST for `top', `left', `width',
;and `height' parameters.
;XEmacs uses this to avoid overriding explicit moves and resizings from
;the user during startup."
;  (setq param-list (cons nil param-list))
;  (let ((tail param-list))
;    (while (consp (cdr tail))
;      (if (and (consp (car (cdr tail)))
;           (memq (car (car (cdr tail))) '(height width top left)))
;      (setcdr tail (cdr (cdr tail)))
;    (setq tail (cdr tail)))))
;  (cdr param-list))


(defun other-frame (arg)
  "Select the ARG'th different visible frame, and raise it.
All frames are arranged in a cyclic order.
This command selects the frame ARG steps away in that order.
A negative ARG moves in the opposite order."
  (interactive "p")
  (let ((frame (selected-frame)))
    (while (> arg 0)
      (setq frame (next-frame frame 'visible))
      (setq arg (1- arg)))
    (while (< arg 0)
      (setq frame (previous-frame frame 'visible))
      (setq arg (1+ arg)))
    (raise-frame frame)
    (select-frame frame)
    ))

;; utility functions
(defun device-or-frame-p (object)
  "Return non-nil if OBJECT is a device or frame."
  (or (devicep object)
      (framep object)))

(defun device-or-frame-type (device-or-frame)
  "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME.
DEVICE-OR-FRAME should be a device or a frame object.  See `device-type'
for a description of the possible types."
  (if (devicep device-or-frame)
      (device-type device-or-frame)
    (frame-type device-or-frame)))


;;;; Frame configurations

;; This stuff doesn't quite work yet - feel free to fix it

;(defun current-frame-configuration ()
;  "Return a list describing the positions and states of all frames.
;Its car is `frame-configuration'.
;Each element of the cdr is a list of the form (FRAME ALIST WINDOW-CONFIG),
;where
;  FRAME is a frame object,
;  ALIST is an association list specifying some of FRAME's parameters, and
;  WINDOW-CONFIG is a window configuration object for FRAME."
;  (cons 'frame-configuration
;    (mapcar (function
;         (lambda (frame)
;           (list frame
;             (frame-parameters frame)
;             (current-window-configuration frame))))
;        (frame-list))))

;(defun set-frame-configuration (configuration &optional nodelete)
;  "Restore the frames to the state described by CONFIGURATION.
;Each frame listed in CONFIGURATION has its position, size, window
;configuration, and other parameters set as specified in CONFIGURATION.
;Ordinarily, this function deletes all existing frames not
;listed in CONFIGURATION.  But if optional second argument NODELETE
;is given and non-nil, the unwanted frames are iconified instead."
;  (or (frame-configuration-p configuration)
;      (signal 'wrong-type-argument
;          (list 'frame-configuration-p configuration)))
;  (let ((config-alist (cdr configuration))
;    frames-to-delete)
;    (mapcar (function
;         (lambda (frame)
;           (let ((parameters (assq frame config-alist)))
;         (if parameters
;             (progn
;               (modify-frame-parameters
;            frame
;            ;; Since we can't set a frame's minibuffer status,
;            ;; we might as well omit the parameter altogether.
;            (let* ((parms (nth 1 parameters))
;                   (mini (assq 'minibuffer parms)))
;              (if mini (setq parms (delq mini parms)))
;              parms))
;               (set-window-configuration (nth 2 parameters)))
;           (setq frames-to-delete (cons frame frames-to-delete))))))
;        (frame-list))
;    (if nodelete
;    ;; Note: making frames invisible here was tried
;    ;; but led to some strange behavior--each time the frame
;    ;; was made visible again, the window manager asked afresh
;    ;; for where to put it.
;    (mapcar 'iconify-frame frames-to-delete)
;      (mapcar 'delete-frame frames-to-delete))))

;(defun frame-configuration-p (object)
;  "Return non-nil if OBJECT seems to be a frame configuration.
;Any list whose car is `frame-configuration' is assumed to be a frame
;configuration."
;  (and (consp object)
;       (eq (car object) 'frame-configuration)))


;;; Iconifying emacs.
;;;
;;; The function iconify-emacs replaces every non-iconified emacs window
;;; with a *single* icon.  Iconified emacs windows are left alone.  When
;;; emacs is in this globally-iconified state, de-iconifying any emacs icon
;;; will uniconify all frames that were visible, and iconify all frames
;;; that were not.  This is done by temporarily changing the value of
;;; `map-frame-hook' to `deiconify-emacs' (which should never be called
;;; except from the map-frame-hook while emacs is iconified).
;;;
;;; The title of the icon representing all emacs frames is controlled by
;;; the variable `icon-name'.  This is done by temporarily changing the
;;; value of `frame-icon-title-format'.  Unfortunately, this changes the
;;; titles of all emacs icons, not just the "big" icon.
;;;
;;; It would be nice if existing icons were removed and restored by
;;; iconifying the emacs process, but I couldn't make that work yet.

(defvar icon-name nil) ; set this at run time, not load time.

(defvar iconification-data nil)

(defun iconify-emacs ()
  "Replace every non-iconified FRAME with a *single* icon.
Iconified frames are left alone.  When XEmacs is in this
globally-iconified state, de-iconifying any emacs icon will uniconify
all frames that were visible, and iconify all frames that were not."
  (interactive)
  (if iconification-data (error "already iconified?"))
  (let* ((frames (frame-list))
     (rest frames)
     (me (selected-frame))
     frame)
    (while rest
      (setq frame (car rest))
      (setcar rest (cons frame (frame-visible-p frame)))
;      (if (memq (cdr (car rest)) '(icon nil))
;      (progn
;        (make-frame-visible frame) ; deiconify, and process the X event
;        (sleep-for 500 t) ; process X events; I really want to XSync() here
;        ))
      (or (eq frame me) (make-frame-invisible frame))
      (setq rest (cdr rest)))
    (or (boundp 'map-frame-hook) (setq map-frame-hook nil))
    (or icon-name
    (setq icon-name (concat invocation-name " @ " (system-name))))
    (setq iconification-data
        (list frame-icon-title-format map-frame-hook frames)
      frame-icon-title-format icon-name
      map-frame-hook 'deiconify-emacs)
    (iconify-frame me)))

(defun deiconify-emacs (&optional ignore)
  (or iconification-data (error "not iconified?"))
  (setq frame-icon-title-format (car iconification-data)
    map-frame-hook (car (cdr iconification-data))
    iconification-data (car (cdr (cdr iconification-data))))
  (while iconification-data
    (let ((visibility (cdr (car iconification-data))))
      (cond ((eq visibility 't)
         (make-frame-visible (car (car iconification-data))))
;        (t ;; (eq visibility 'icon)
;         (make-frame-visible (car (car iconification-data)))
;         (sleep-for 500 t) ; process X events; I really want to XSync() here
;         (iconify-frame (car (car iconification-data))))
        ;; (t nil)
        ))
    (setq iconification-data (cdr iconification-data))))

(defun suspend-or-iconify-emacs ()
  "Calls iconify-emacs if frame is an X frame, otherwise calls suspend-emacs"
  (interactive)
  (if (eq (frame-type (selected-frame)) 'x)
      (iconify-emacs)
    (suspend-emacs)))


;;; auto-raise and auto-lower

(defvar auto-raise-frame nil
  "*If true, frames will be raised to the top when selected.
Under X, most ICCCM-compliant window managers will have an option to do this
for you, but this variable is provided in case you're using a broken WM.")

(defvar auto-lower-frame nil
  "*If true, frames will be lowered to the bottom when no longer selected.
Under X, most ICCCM-compliant window managers will have an option to do this
for you, but this variable is provided in case you're using a broken WM.")

(defun default-select-frame-hook ()
  "Implements the `auto-raise-frame' variable.
For use as the value of `select-frame-hook'."
  (if auto-raise-frame (raise-frame (selected-frame))))

(defun default-deselect-frame-hook ()
  "Implements the `auto-lower-frame' variable.
For use as the value of `deselect-frame-hook'."
  (if auto-lower-frame (lower-frame (selected-frame))))

(or select-frame-hook
    (add-hook 'select-frame-hook 'default-select-frame-hook))

(or deselect-frame-hook
    (add-hook 'deselect-frame-hook 'default-deselect-frame-hook))


;;; Application-specific frame-management

(defvar get-frame-for-buffer-default-frame-name nil
  "The default frame to select; see doc of `get-frame-for-buffer'.")

(defvar get-frame-for-buffer-default-instance-limit nil)

(defun get-frame-name-for-buffer (buffer)
  (let ((mode (and (get-buffer buffer)
           (save-excursion (set-buffer buffer)
                   major-mode))))
    (or (get mode 'frame-name)
    get-frame-for-buffer-default-frame-name)))

(defun get-frame-for-buffer-sorted-frame-list ()
  (sort (frame-list)
    #'(lambda (s1 s2)
        (cond ((frame-totally-visible-p s2)
           nil)
          ((not (frame-visible-p s2))
           (frame-visible-p s1))
          ((not (frame-totally-visible-p s2))
           (and (frame-visible-p s1)
            (frame-totally-visible-p s1)))))))

(defun get-frame-for-buffer-make-new-frame (buffer &optional frame-name)
  (let* ((fr (make-frame (and frame-name (list (cons 'name frame-name)))))
     (w (frame-root-window fr)))
    ;;
    ;; Make the one buffer being displayed in this newly created
    ;; frame be the buffer of interest, instead of something
    ;; random, so that it won't be shown in two-window mode.
    ;; Avoid calling switch-to-buffer here, since that's something
    ;; people might want to call this routine from.
    ;;
    ;; (If the root window doesn't have a buffer, then that means
    ;; there is more than one window on the frame, which can only
    ;; happen if the user has done something funny on the frame-
    ;; creation-hook.  If that's the case, leave it alone.)
    ;;
    (if (window-buffer w)
    (set-window-buffer w buffer))
    fr))

(defun get-frame-for-buffer-noselect (buffer
                       &optional not-this-window-p on-frame)
  "Return a frame in which to display BUFFER.
This is a subroutine of `get-frame-for-buffer' (which see)."
  (let (name limit)
    (cond
     ((or on-frame (eq (selected-window) (minibuffer-window)))
      ;; don't switch frames if a frame was specified, or to list
      ;; completions from the minibuffer, etc.
      nil)

     ((setq name (get-frame-name-for-buffer buffer))
      ;;
      ;; This buffer's mode expressed a preference for a frame of a particular
      ;; name.  That always takes priority.
      ;;
      (let ((limit (get name 'instance-limit))
        (matching-frames '())
        frames frame already-visible)
    ;; Sort the list so that iconic frames will be found last.  They
    ;; will be used too, but mapped frames take precedence.  And
    ;; fully visible frames come before occluded frames.
    (setq frames (get-frame-for-buffer-sorted-frame-list))
    ;; but the selected frame should come first, even if it's occluded,
    ;; to minimize thrashing.
    (setq frames (cons (selected-frame)
               (delq (selected-frame) frames)))

    (setq name (symbol-name name))
    (while frames
      (setq frame (car frames))
      (if (equal name (frame-name frame))
          (if (get-buffer-window buffer frame)
          (setq already-visible frame
            frames nil)
        (setq matching-frames (cons frame matching-frames))))
      (setq frames (cdr frames)))
    (cond (already-visible
           already-visible)
          ((or (null matching-frames)
           (eq limit 0) ; means create with reckless abandon
           (and limit (< (length matching-frames) limit)))
           (get-frame-for-buffer-make-new-frame buffer name))
          (t
           ;; do not switch any of the window/buffer associations in an
           ;; existing frame; this function only picks a frame; the
           ;; determination of which windows on it get reused is up to
           ;; display-buffer itself.
;;           (or (window-dedicated-p (selected-window))
;;           (switch-to-buffer buffer))
           (car matching-frames)))))

     ((setq limit get-frame-for-buffer-default-instance-limit)
      ;;
      ;; This buffer's mode did not express a preference for a frame of a
      ;; particular name, but the user wants a new frame rather than
      ;; reusing the existing one.
      (let ((frames (get-frame-for-buffer-sorted-frame-list)))
    ;; put the selected frame last.  The user wants a new frame,
    ;; so don't reuse the existing one unless forced to.
    (setq frames (append (delq (selected-frame) frames) (list frames)))
    (if (or (eq limit 0) ; means create with reckless abandon
        (< (length frames) limit))
        (get-frame-for-buffer-make-new-frame buffer)
      (car frames))))

     (t
      ;;
      ;; This buffer's mode did not express a preference for a frame of a
      ;; particular name.  So try to find a frame already displaying this
      ;; buffer.
      ;;
      (let ((w (or (get-buffer-window buffer t)        ; check visible first
           (get-buffer-window buffer t t))))    ; then iconic
    (cond ((null w)
           ;; It's not in any window - return nil, meaning no frame has
           ;; preference.
           nil)
          ((and not-this-window-p
            (eq (selected-frame) (window-frame w)))
           ;; It's in a window, but on this frame, and we have been
           ;; asked to pick another window.  Return nil, meaning no
           ;; frame has preference.
           nil)
          (t
           ;; Otherwise, return the frame of the buffer's window.
           (window-frame w))))))))


;; The pre-display-buffer-function is called for effect, so this needs to
;; actually select the frame it wants.  Fdisplay_buffer() takes notice of
;; changes to the selected frame.
(defun get-frame-for-buffer (buffer &optional not-this-window-p on-frame)
  "Select and return a frame in which to display BUFFER.
Normally, the buffer will simply be displayed in the current frame.
But if the symbol naming the major-mode of the buffer has a 'frame-name
property (which should be a symbol), then the buffer will be displayed in
a frame of that name.  If there is no frame of that name, then one is
created.

If the major-mode doesn't have a 'frame-name property, then the frame
named by `get-frame-for-buffer-default-frame-name' will be used.  If
that is nil (the default) then the currently selected frame will used.

If the frame-name symbol has an 'instance-limit property (an integer)
then each time a buffer of the mode in question is displayed, a new frame
with that name will be created, until there are `instance-limit' of them.
If instance-limit is 0, then a new frame will be created each time.

If a buffer is already displayed in a frame, then `instance-limit' is
ignored, and that frame is used.

If the frame-name symbol has a 'frame-defaults property, then that is
prepended to the `default-frame-alist' when creating a frame for the
first time.

This function may be used as the value of `pre-display-buffer-function',
to cause the display-buffer function and its callers to exhibit the above
behavior."
  (let ((old-frames (visible-frame-list))
    (frame (get-frame-for-buffer-noselect
         buffer not-this-window-p on-frame)))
    (if (not (eq frame (selected-frame)))
    nil
      (select-frame frame)
      (or (member frame old-frames)
        ;; If the frame was already visible, just focus on it.
        ;; If it wasn't visible (it was just created, or it used
        ;; to be iconified) then uniconify, raise, etc.
      (make-frame-visible frame))
      frame)))

(defun frames-of-buffer (&optional buffer visible-only)
  "Return list of frames that BUFFER is currently being displayed on.
If the buffer is being displayed on the currently selected frame, that frame
is first in the list.  VISIBLE-ONLY will only list non-iconified frames."
  (let ((list (windows-of-buffer buffer))
    (cur-frame (selected-frame))
    next-frame frames save-frame)

    (while list
      (if (memq (setq next-frame (window-frame (car list)))
        frames)
      nil
    (if (eq cur-frame next-frame)
        (setq save-frame next-frame)
      (and
       (or (not visible-only)
           (eq t (frame-visible-p next-frame)))
       (setq frames (append frames (list next-frame))))))
    (setq list (cdr list)))

    (if save-frame
    (append (list save-frame) frames)
      frames)))

(defun show-temp-buffer-in-current-frame (buffer)
  "For use as the value of temp-buffer-show-function:
always displays the buffer in the current frame, regardless of the behavior
that would otherwise be introduced by the `pre-display-buffer-function', which
is normally set to `get-frame-for-buffer' (which see)."
  (let ((pre-display-buffer-function nil)) ; turn it off, whatever it is
    (let ((window (display-buffer buffer)))
      (if (not (eq (selected-frame) (window-frame window)))
      ;; only the pre-display-buffer-function should ever do this.
      (error "display-buffer switched frames on its own!!"))
      (setq minibuffer-scroll-window window)
      (set-window-start window 1) ; obeys narrowing
      (set-window-point window 1)
      nil)))

(setq pre-display-buffer-function 'get-frame-for-buffer)
(setq temp-buffer-show-function 'show-temp-buffer-in-current-frame)


;; from Bob Weiner <[e-mail]>, modified by Ben Wing
(defun delete-other-frames (&optional frame)
  "Delete all but FRAME (or the selected frame)."
  (interactive)
  (mapcar 'delete-frame (delq (or frame (selected-frame)) (frame-list))))


(provide 'frame)

;;; frame.el ends here